home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_200 / 297_01 / prbltin.c < prev    next >
C/C++ Source or Header  |  1991-12-30  |  57KB  |  1,842 lines
  1. /* prbltin.c */
  2. /* The builtin predicates are defined here.
  3.  * If you want lots of builtins then make several files that
  4.  * include prbltin.h.
  5.  */
  6.  
  7. /* Dec 18 88 HdeF Simplified remove clause so that it expects just one
  8.  *      argument.
  9.  * 12/25/91 HdeF, added repeat,gennum predicates
  10.  * 01/01/92 HdeF, added reverse_trace_mode, no_reverse_trace_mode
  11.  */
  12. #include <stdio.h>
  13. #include <ctype.h>
  14. #include <assert.h>
  15. #include "prtypes.h"
  16. #include "prbltin.h"
  17. #include "prlush.h"
  18.  
  19. #define ATOMORSTRING     "atom or string"
  20. #define CANTOPEN     "can't open %s"
  21. #define TOOMANYFILES     "Too many open files"
  22.  
  23. extern subst_ptr_t Subst_mem; /* bottom of (global) variable bindings stack */
  24. extern subst_ptr_t my_Subst_alloc();
  25.  
  26. extern string_ptr_t get_string();
  27. extern atom_ptr_t   Nil;
  28. extern FILE *        Curr_infile;
  29. extern FILE *        Curr_outfile;
  30. extern node_ptr_t   ND_builtin_next_nodeptr;/* from prlush.c */
  31. static int Nbuiltins; /* not used but you could used this to keep track of
  32.                         the builtins you add */
  33. int Trace_flag; /* used by Ptrace(), Pnotrace(), lush() */
  34. int Tracing_now;
  35.  
  36. /* This is used to test if an atom is a builtin. 
  37.  * We rely on the fact that any atom less than LastBuiltin is created by
  38.  * a call to make_builtin()
  39.  */
  40. atom_ptr_t LastBuiltin;
  41.  
  42. /****************************************************************************
  43.                 make_builtin()
  44.  This associates a name used at the interpreter level with a builtin.
  45.  ****************************************************************************/
  46. void make_builtin(fun, prolog_name)
  47. intfun fun;
  48. char *prolog_name;
  49. {
  50.         atom_ptr_t atomptr, intern();
  51.  
  52.         atomptr = intern(prolog_name);
  53.         ATOMPTR_BUILTIN(atomptr) = fun;
  54.         LastBuiltin = atomptr;
  55.         record_pred(atomptr);
  56.         Nbuiltins++;
  57. }
  58.  
  59. /*****************************************************************************
  60.                         nth_arg()
  61.  Returns NULL if error .
  62.  Otherwise returns the nth argument of current goal's arguments.
  63.  The return value is equal to DerefNode
  64.  Obviously one could be more efficient than here.
  65.  *****************************************************************************/
  66. node_ptr_t nth_arg(narg)
  67. {
  68.  
  69.         node_ptr_t rest_args;
  70.  
  71.         dereference(Arguments, SubstGoal);
  72.         if(NODEPTR_TYPE(DerefNode) != PAIR)
  73.         {
  74.                 return(NULL);
  75.         }
  76.         rest_args = DerefNode;
  77.         --narg;
  78.         while(narg)
  79.         {
  80.                 --narg;
  81.                 dereference(NODEPTR_TAIL(rest_args), DerefSubst);
  82.                 if(NODEPTR_TYPE(DerefNode) != PAIR)
  83.                 {
  84.                         return(NULL);
  85.                 }
  86.                 rest_args = DerefNode;
  87.         }
  88.         dereference(NODEPTR_HEAD(rest_args), DerefSubst);
  89.         return(DerefNode);
  90. }
  91.  
  92. /**********************************************************************
  93.                         type_first_arg()
  94. Returns true if the type of the first arg to the call is equal
  95.  to the argument of the function.
  96.  **********************************************************************/
  97. type_first_arg(type)
  98. objtype_t type;
  99. {
  100. dereference(Arguments, SubstGoal);
  101. if(NODEPTR_TYPE(DerefNode) != PAIR)
  102.   return(nargerr(1)); 
  103.   else 
  104.     dereference(NODEPTR_HEAD(DerefNode), DerefSubst);
  105.     return(NODEPTR_TYPE(DerefNode) == type);
  106. }
  107.  
  108. /*-------------------------------------------------------------------*/
  109. /* unify the nth argument of goal with an int of value val */
  110. bind_int(narg, val)
  111. integer val;
  112. {
  113.         extern subst_ptr_t Subst_mem;
  114.         node_ptr_t nodeptr, get_node();
  115.  
  116.         if(!nth_arg(narg))return(nargerr(narg));
  117.  
  118.         nodeptr = get_node(DYNAMIC);
  119.         NODEPTR_TYPE(nodeptr) = INT;
  120.         NODEPTR_INT(nodeptr) = val;
  121.  
  122.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  123. }
  124.  
  125. #ifdef CHARACTER
  126. /*-------------------------------------------------------------------*/
  127. /* unify the nth argument of goal with a char of value val */
  128. bind_character(narg, val)
  129. uchar_t val;
  130. {
  131.         extern subst_ptr_t Subst_mem;
  132.         node_ptr_t nodeptr, get_node();
  133.  
  134.         if(!nth_arg(narg))return(nargerr(narg));
  135.  
  136.         nodeptr = get_node(DYNAMIC);
  137.         NODEPTR_TYPE(nodeptr) = CHARACTER;
  138.         NODEPTR_CHARACTER(nodeptr) = val;
  139.  
  140.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  141. }
  142. #endif
  143.  
  144. #ifdef REAL
  145. /*-------------------------------------------------------------------*/
  146. /* unify the nth argument of goal with a real of value val */
  147. bind_real(narg, val)
  148. real val;
  149. {
  150.         node_ptr_t nodeptr, get_node();
  151.         real_ptr_t realptr, get_real();
  152.  
  153.         if(!nth_arg(narg))return(nargerr(narg));
  154.  
  155.         nodeptr = get_node(DYNAMIC);
  156.         NODEPTR_TYPE(nodeptr) = REAL;
  157.         realptr = get_real(DYNAMIC);
  158.         *realptr = val;
  159.         NODEPTR_REALP(nodeptr) = realptr;
  160.  
  161.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  162. }
  163. #endif
  164.  
  165. /*-------------------------------------------------------------------*/
  166. /* unify the nth argument of goal with an int of value val */
  167. bind_clause(narg, val)
  168. clause_ptr_t val;
  169. {
  170.         node_ptr_t nodeptr, get_node();
  171.         extern subst_ptr_t Subst_mem;
  172.  
  173.         if(!nth_arg(narg))return(nargerr(narg));
  174.  
  175.         nodeptr = get_node(DYNAMIC);
  176.         NODEPTR_TYPE(nodeptr) = CLAUSE;
  177.         NODEPTR_CLAUSE(nodeptr) = val;
  178.  
  179.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  180. }
  181.  
  182.  
  183. /*-------------------------------------------------------------------*/
  184. /* unify the nth argument of goal with an atom*/
  185. bind_atom(narg, atomptr)
  186. atom_ptr_t atomptr;
  187. {
  188.         extern subst_ptr_t Subst_mem;
  189.         node_ptr_t nodeptr, get_node();
  190.  
  191.         if(!nth_arg(narg))return(nargerr(narg));
  192.  
  193.         nodeptr = get_node(DYNAMIC);
  194.         NODEPTR_TYPE(nodeptr) = ATOM;
  195.         NODEPTR_ATOM(nodeptr) = atomptr;
  196.  
  197.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  198. }
  199. /*-------------------------------------------------------------------*/
  200. /* unify the nth argument of goal with a copy of the string*/
  201. bind_string(narg, stringptr)
  202. string_ptr_t stringptr;
  203. {
  204.         extern subst_ptr_t Subst_mem;
  205.         node_ptr_t nodeptr, get_node();
  206.         string_ptr_t s;
  207.  
  208.         if(!nth_arg(narg))return(nargerr(narg));
  209.  
  210.         nodeptr = get_node(DYNAMIC);
  211.         NODEPTR_TYPE(nodeptr) = STRING;
  212.         s = get_string((my_alloc_size_t)strlen(stringptr)+1 , DYNAMIC);
  213.         strcpy(s, stringptr);
  214.         NODEPTR_STRING(nodeptr) = s;
  215.  
  216.  
  217.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  218. }
  219.  
  220. /*----------------------------------------------------------------------------
  221.   The functions corresponding to the builtins are as follows.
  222.   The correct syntax for the call refers to the syntax in 
  223.   prmanual.txt.
  224.   ----------------------------------------------------------------------------*/
  225.  
  226.  
  227. /******************************************************************************
  228.                         (tell <output_file:string>)
  229. Send output to file. Open file if not already open.
  230. As in Edinburgh Prolog.
  231. See Clocksin and Mellish, or Bratko for more details, or read the code!
  232.  ******************************************************************************/
  233. /* this stores the open output files */
  234. struct named_ofile Open_ofiles[MAXOPEN];/* the value of MAXOPEN depends on the OS */
  235.  
  236. /* this stores the open input files */
  237. struct named_ifile Open_ifiles[MAXOPEN];/* the value of MAXOPEN depends on the OS */
  238.  
  239. void ini_named_files()
  240. {
  241. int i;
  242.  
  243.      Open_ofiles[0].o_filename = "user";
  244.      Open_ofiles[0].o_fp = stdout;
  245.  
  246. for(i = 1 ; i < MAXOPEN; i++)
  247.    {
  248.      Open_ofiles[i].o_filename = "";
  249.      Open_ofiles[i].o_fp = NULL;
  250.    }
  251.  
  252.      Open_ifiles[0].i_filename = "user";
  253.      Open_ifiles[0].i_fp = stdin;
  254.  
  255. for(i = 1 ; i < MAXOPEN; i++)
  256.    {
  257.      Open_ifiles[i].i_filename = "";
  258.      Open_ifiles[i].i_fp = NULL;
  259.    }
  260.  
  261. }
  262.  
  263. open_output(filename)
  264. char *filename;
  265. {
  266. int i, unused;
  267. FILE *ofp;
  268.  
  269. for(i = 0, unused = MAXOPEN; i < MA